home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / TOOLBARS / TRACKBAR / TRACKBAR.ZIP / TRACKBAR.PAS < prev    next >
Pascal/Delphi Source File  |  1996-01-06  |  13KB  |  385 lines
  1. unit Trackbar;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs;
  8.  
  9. const
  10.   TBS_AUTOTICKS           = $0001;
  11.   TBS_VERT                = $0002;
  12.   TBS_LEFT                = $0004;
  13.   TBS_BOTH                = $0008;
  14.   TBS_NOTICKS             = $0010;
  15.   TBS_ENABLESELRANGE      = $0020;
  16.   TBS_FIXEDLENGTH         = $0040;
  17.   TBS_NOTHUMB             = $0080;
  18.  
  19.   TBM_GETPOS              = WM_USER;             {}
  20.   TBM_GETRANGEMIN         = WM_USER+1;           {}
  21.   TBM_GETRANGEMAX         = WM_USER+2;           {}
  22.   TBM_GETTIC              = WM_USER+3;           {}
  23.   TBM_SETTIC              = WM_USER+4;           {}
  24.   TBM_SETPOS              = WM_USER+5;           {}
  25.   TBM_SETRANGE            = WM_USER+6;           {}
  26.   TBM_SETRANGEMIN         = WM_USER+7;           {}
  27.   TBM_SETRANGEMAX         = WM_USER+8;           {}
  28.   TBM_CLEARTICS           = WM_USER+9;           {}
  29.   TBM_SETSEL              = WM_USER+10;          {}
  30.   TBM_SETSELSTART         = WM_USER+11;          {}
  31.   TBM_SETSELEND           = WM_USER+12;          {}
  32.   TBM_GETPTICS            = WM_USER+14;
  33.   TBM_GETTICPOS           = WM_USER+15;          {}
  34.   TBM_GETNUMTICS          = WM_USER+16;          {}
  35.   TBM_GETSELSTART         = WM_USER+17;          {}
  36.   TBM_GETSELEND           = WM_USER+18;          {}
  37.   TBM_CLEARSEL            = WM_USER+19;          {}
  38.   TBM_SETTICFREQ          = WM_USER+20;          {}
  39.   TBM_SETPAGESIZE         = WM_USER+21;          {}
  40.   TBM_GETPAGESIZE         = WM_USER+22;          {}
  41.   TBM_SETLINESIZE         = WM_USER+23;          {}
  42.   TBM_GETLINESIZE         = WM_USER+24;          {}
  43.   TBM_GETTHUMBRECT        = WM_USER+25;          {}
  44.   TBM_GETCHANNELRECT      = WM_USER+26;          {}
  45.   TBM_SETTHUMBLENGTH      = WM_USER+27;          {}
  46.   TBM_GETTHUMBLENGTH      = WM_USER+28;          {}
  47.  
  48.   TB_LINEUP               = 0;
  49.   TB_LINEDOWN             = 1;
  50.   TB_PAGEUP               = 2;
  51.   TB_PAGEDOWN             = 3;
  52.   TB_THUMBPOSITION        = 4;
  53.   TB_THUMBTRACK           = 5;
  54.   TB_TOP                  = 6;
  55.   TB_BOTTOM               = 7;
  56.   TB_ENDTRACK             = 8;
  57.  
  58. {
  59. TB_BOTTOM    VK_END
  60. TB_ENDTRACK    WM_KEYUP (the user released a key that sent a relevant virtual-key code)
  61. TB_LINEDOWN    VK_RIGHT or VK_DOWN
  62. TB_LINEUP    VK_LEFT or VK_UP
  63. TB_PAGEDOWN    VK_NEXT (the user clicked the channel below or to the right of the slider)
  64. TB_PAGEUP    VK_PRIOR (the user clicked the channel above or to the left of the slider)
  65. TB_THUMBPOSITION    WM_LBUTTONUP following a TB_THUMBTRACK notification message
  66. TB_THUMBTRACK    Slider movement (the user dragged the slider)
  67. TB_TOP    VK_HOMEtype
  68. }
  69.  
  70. type
  71.   tbStyle = (tbAutoticks, tbVert, tbReversed, tbBoth, tbNoTicks, tbEnableSelRange, tbFixedLength, tbNoThumb);
  72.   tbStyles = set of tbStyle;
  73.  
  74.   TTrackbarKind = (tkHoriz, tkVert);
  75.  
  76.   TTrackbar = class(TWinControl)
  77.     private
  78.     Styles : tbStyles;
  79.     iMax : LongInt;
  80.     iMin : LongInt;
  81.     iSelectionStart : Longint;
  82.     iSelectionEnd   : LongInt;
  83.     iPos : LongInt;
  84.     iTickFreq : Integer;
  85.     iLineSize, iPageSize : LongInt;
  86.     iThumbLength : Integer;
  87.  
  88.     EvLineUp         : TNotifyEvent;
  89.     EvLineDown       : TNotifyEvent;
  90.     EvPageUp         : TNotifyEvent;
  91.     EvPageDown       : TNotifyEvent;
  92.     EvThumbPosition  : TNotifyEvent;
  93.     EvThumbTrack     : TNotifyEvent;
  94.     EvTop            : TNotifyEvent;
  95.     EvBottom         : TNotifyEvent;
  96.     EvEndTrack       : TNotifyEvent;
  97.  
  98.     procedure SetMin (value : LongInt);
  99.     procedure SetMax (value : LongInt);
  100.     procedure SetSelectionStart (value : LongInt);
  101.     procedure SetSelectionEnd (value : LongInt);
  102.     procedure SetPos (value : LongInt);
  103.     function GetPos : LongInt;
  104.     procedure SetStyles (value : tbStyles);
  105.     procedure SetTickFreq (value : Integer);
  106.     procedure SetPageSize (value : LongInt);
  107.     procedure SetLineSize (value : LongInt);
  108.     procedure SetThumbLength (value : Integer);
  109.     procedure wmHScroll (var Msg : TMessage); message CN_HSCROLL;
  110.  
  111.     protected
  112.     constructor Create (AOwner : TComponent); override;
  113.     procedure CreateParams (var Params: TCreateParams); override;
  114.     procedure CreateHandle; override;
  115.  
  116.     public
  117.     procedure SetTic (position : LongInt);
  118.     function GetTic (index : Integer) : LongInt;
  119.     function GetTicPos (index : Integer) : LongInt;
  120.     procedure ClearTics (Redraw : boolean);
  121.     function GetNumTics : Integer;
  122.     procedure ClearSelection (Redraw : boolean);
  123.     procedure GetThumbRect (var Rect : TRect);
  124.     procedure GetChannelRect (var Rect : TRect);
  125.  
  126.     published
  127.     property Min : LongInt read iMin write SetMin;
  128.     property Max : LongInt read iMax write SetMax;
  129.     property SelectionStart : LongInt read iSelectionStart write SetSelectionStart;
  130.     property SelectionEnd : LongInt read iSelectionEnd write SetSelectionEnd;
  131.     property Position : LongInt read GetPos write SetPos;
  132.     property TickFreq : Integer read iTickFreq write SetTickFreq default 1;
  133.     property Style : tbStyles read Styles write SetStyles;
  134.     property PageSize : LongInt read iPageSize write SetPageSize default 2;
  135.     property LineSize : LongInt read iLineSize write SetLineSize default 1;
  136.     property ThumbLength : Integer read iThumbLength write SetThumbLength default 19;
  137.  
  138.     property Visible;
  139.     property Enabled;
  140.  
  141.     property OnLineUp        : TNotifyEvent read EvLineUp write EvLineUp;
  142.     property OnLineDown      : TNotifyEvent read EvLineDown write EvLineDown;
  143.     property OnPageUp        : TNotifyEvent read EvPageUp write EvPageUp;
  144.     property OnPageDown      : TNotifyEvent read EvPageDown write EvPageDown;
  145.     property OnThumbPosition : TNotifyEvent read EvThumbPosition write EvThumbPosition;
  146.     property OnThumbTrack    : TNotifyEvent read EvThumbTrack write EvThumbTrack;
  147.     property OnTop           : TNotifyEvent read EvTop write EvTop;
  148.     property OnBottom        : TNotifyEvent read EvBottom write EvBottom;
  149.     property OnEndTrack        : TNotifyEvent read EvEndTrack write EvEndTrack;
  150.  
  151.     property OnEnter;
  152.     property OnExit;
  153.     property OnDragDrop;
  154.     property OnDragOver;
  155.     property OnEndDrag;
  156.     property OnKeyDown;
  157.     property OnKeyPress;
  158.     property OnKeyUp;
  159.   end;
  160.  
  161. procedure Register;
  162.  
  163. implementation
  164.  
  165. uses commctrl;
  166.  
  167. constructor TTrackbar.Create (AOwner : TComponent);
  168. begin
  169.   inherited Create (AOwner);
  170.   Width := 200;
  171.   Height := 30;
  172.   iTickFreq := 1;
  173.   iLineSize := 1;
  174.   iPageSize := 2;
  175.   iThumbLength := 19;
  176.   iMax := 10;
  177. end;
  178.  
  179. procedure TTrackbar.CreateParams (var Params: TCreateParams);
  180. begin
  181.   InitCommonControls;
  182.   inherited CreateParams(Params);
  183.   CreateSubClass(Params, 'msctls_trackbar');
  184.  
  185.   if tbAutoticks in Styles then with Params do Style := Style or TBS_AUTOTICKS;
  186.   if tbVert in styles then with Params do Style := Style or TBS_VERT;
  187.   if tbReversed in styles then with Params do Style := Style or TBS_LEFT;
  188.   if tbBoth in styles then with Params do Style := Style or TBS_BOTH;
  189.   if tbNoTicks in styles then with Params do Style := Style or TBS_NOTICKS;
  190.   if SelectionStart <> SelectionEnd then styles := styles + [tbEnableSelRange];
  191.   if tbEnableSelRange in styles then with Params do Style := Style or TBS_ENABLESELRANGE;
  192.   if tbFixedLength in styles then with Params do Style := Style or TBS_FIXEDLENGTH;
  193.   if tbNoThumb in styles then with Params do Style := Style or TBS_NOTHUMB;
  194. end;
  195.  
  196. procedure TTrackbar.CreateHandle;
  197. var temp : LongInt;
  198. begin
  199.   inherited CreateHandle;
  200.   if Max <> SendMessage (Handle, TBM_GETRANGEMAX, 0, 0) then
  201.     SendMessage (Handle, TBM_SETRANGEMAX, 0, iMax);
  202.  
  203.   if Min <> SendMessage (Handle, TBM_GETRANGEMIN, 0, 0) then
  204.     SendMessage (Handle, TBM_SETRANGEMIN, 0, iMin);
  205.  
  206.   if SelectionStart <> SendMessage (Handle, TBM_GETSELSTART, 0, 0) then
  207.     SendMessage (Handle, TBM_SETSELSTART, 0, iSelectionStart);
  208.  
  209.   if SelectionEnd <> SendMessage (Handle, TBM_GETSELEND, 0, 0) then
  210.     SendMessage (Handle, TBM_SETSELEND, 0, iSelectionEnd);
  211.  
  212.   if iPos <> SendMessage (Handle, TBM_GETPOS, 0, 0) then
  213.     SendMessage (Handle, TBM_SETPOS, Ord (True), iPos);
  214.  
  215.   if PageSize <> SendMessage (Handle, TBM_GETPAGESIZE, 0, 0) then
  216.     SendMessage (Handle, TBM_SETPAGESIZE, 0, iPageSize);
  217.  
  218.   if LineSize <> SendMessage (Handle, TBM_GETLINESIZE, 0, 0) then
  219.     SendMessage (Handle, TBM_SETLINESIZE, 0, iLineSize);
  220.  
  221.   if ThumbLength <> SendMessage (Handle, TBM_GETTHUMBLENGTH, 0, 0) then
  222.     SendMessage (Handle, TBM_SETTHUMBLENGTH, iThumbLength, 0);
  223.  
  224.   SendMessage (Handle, TBM_SETTICFREQ, iTickFreq, 0)
  225. end;
  226.  
  227. procedure TTrackbar.SetMin (value : LongInt);
  228. begin
  229.   if iMin <> value then
  230.   begin
  231.     iMin := value;
  232.     SendMessage (Handle, TBM_SETRANGEMIN, Ord (True), iMin)
  233.   end
  234. end;
  235.  
  236. procedure TTrackbar.SetMax (value : LongInt);
  237. begin
  238.   if value <> iMax then
  239.   begin
  240.     iMax := value;
  241.     SendMessage (Handle, TBM_SETRANGEMAX, Ord (True), iMax)
  242.   end
  243. end;
  244.  
  245. procedure TTrackbar.SetSelectionStart (value : LongInt);
  246. begin
  247.   if iSelectionStart <> value then
  248.   begin
  249.     iSelectionStart := value;
  250.     if SelectionStart <> SelectionEnd then SetStyles (Styles + [tbEnableSelRange]);
  251.     SendMessage (Handle, TBM_SETSELSTART, Ord (True), iSelectionStart)
  252.   end
  253. end;
  254.  
  255. procedure TTrackbar.SetSelectionEnd (value : LongInt);
  256. begin
  257.   if value <> iSelectionEnd then
  258.   begin
  259.     iSelectionEnd := value;
  260.     SendMessage (Handle, TBM_SETSELEND, Ord (True), iSelectionEnd)
  261.   end
  262. end;
  263.  
  264. procedure TTrackbar.SetPos (value : LongInt);
  265. begin
  266.   if value <> iPos then
  267.   begin
  268.     iPos := value;
  269.     SendMessage (Handle, TBM_SETPOS, Ord (True), iPos)
  270.   end
  271. end;
  272.  
  273. function TTrackbar.GetPos : LongInt;
  274. begin
  275.   iPos := SendMessage (Handle, TBM_GETPOS, 0, 0);
  276.   result := iPos
  277. end;
  278.  
  279. procedure TTrackbar.SetPageSize (value : LongInt);
  280. begin
  281.   if value <> iPageSize then
  282.   begin
  283.     iPageSize := value;
  284.     SendMessage (Handle, TBM_SETPAGESIZE, 0, iPageSize)
  285.   end
  286. end;
  287.  
  288. procedure TTrackbar.SetLineSize (value : LongInt);
  289. begin
  290.   if value <> iLineSize then
  291.   begin
  292.     iLineSize := value;
  293.     SendMessage (Handle, TBM_SETLINESIZE, 0, iLineSize)
  294.   end
  295. end;
  296.  
  297. procedure TTrackbar.SetThumbLength (value : Integer);
  298. begin
  299.   if value <> iThumbLength then
  300.   begin
  301.     iThumbLength := value;
  302.     SendMessage (Handle, TBM_SETTHUMBLENGTH, value, 0)
  303.   end
  304. end;
  305.  
  306. procedure TTrackbar.SetStyles (value : tbStyles);
  307. begin
  308.   if value <> Styles then
  309.   begin
  310.     Styles := value;
  311.     RecreateWnd
  312.   end
  313. end;
  314.  
  315. procedure TTrackbar.SetTickFreq (value : Integer);
  316. begin
  317.   if value <> iTickFreq then
  318.   begin
  319.     iTickFreq := value;
  320.     SendMessage (Handle, TBM_SETTICFREQ, value, 0)
  321.   end
  322. end;
  323.  
  324. procedure TTrackbar.SetTic (position : LongInt);
  325. begin
  326.   SendMessage (Handle, TBM_SETTIC, 0, position);
  327. end;
  328.  
  329. function TTrackbar.GetTic (index : Integer) : LongInt;
  330. begin
  331.   result := SendMessage (Handle, TBM_GETTIC, index, 0);
  332. end;
  333.  
  334. function TTrackbar.GetTicPos (index : Integer) : LongInt;
  335. begin
  336.   result := SendMessage (Handle, TBM_GETTICPOS, index, 0);
  337. end;
  338.  
  339. procedure TTrackbar.ClearTics (Redraw : boolean);
  340. begin
  341.   SendMessage (Handle, TBM_CLEARTICS, Ord (Redraw), 0);
  342. end;
  343.  
  344. function TTrackbar.GetNumTics : Integer;
  345. begin
  346.   result := SendMessage (Handle, TBM_GETNUMTICS, 0, 0);
  347. end;
  348.  
  349. procedure TTrackbar.ClearSelection (Redraw : boolean);
  350. begin
  351.   SendMessage (Handle, TBM_CLEARSEL, Ord (Redraw), 0);
  352. end;
  353.  
  354. procedure TTrackbar.GetThumbRect (var Rect : TRect);
  355. begin
  356.   SendMessage (Handle, TBM_GETTHUMBRECT, 0, LongInt (@Rect))
  357. end;
  358.  
  359. procedure TTrackbar.GetChannelRect (var Rect : TRect);
  360. begin
  361.   SendMessage (Handle, TBM_GETCHANNELRECT, 0, LongInt (@Rect))
  362. end;
  363.  
  364. procedure TTrackbar.wmHScroll (var Msg : TMessage);
  365. begin
  366.   case Msg.wParam of
  367.     TB_LINEUP        : if Assigned (EvLineUp) then EvLineUp (self);
  368.     TB_LINEDOWN      : if Assigned (EvLineDown) then EvLineDown (self);
  369.     TB_PAGEUP        : if Assigned (EvPageUp) then EvPageUp (self);
  370.     TB_PAGEDOWN      : if Assigned (EvPageDown) then EvPageDown (self);
  371.     TB_THUMBPOSITION : if Assigned (EvThumbPosition) then EvThumbPosition (self);
  372.     TB_THUMBTRACK    : if Assigned (EvThumbTrack) then EvThumbTrack (self);
  373.     TB_TOP           : if Assigned (EvTop) then EvTop (self);
  374.     TB_BOTTOM        : if Assigned (EvBottom) then EvBottom (self);
  375.     TB_ENDTRACK      : if Assigned (EvEndTrack) then EvEndTrack (self)
  376.   end
  377. end;
  378.  
  379. procedure Register;
  380. begin
  381.   RegisterComponents('Windows95', [TTrackbar]);
  382. end;
  383.  
  384. end.
  385.